Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part04

Text File | 1990-02-26 | 89.9 KB | 4,152 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i091: XLisP 2.1 sources 2/5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 91
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part04

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xlbfun.c
#    xlcont.c
#    xldbug.c
#    xldmem.c
#    xldmem.h
#    xleval.c
# This archive created: Sun Feb 18 07:45:24 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlbfun.c'" '(12891 characters)'
if test -f 'xlbfun.c'
then
    echo shar: over-writing existing file "'xlbfun.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlbfun.c'
X/* xlbfun.c - xlisp basic built-in functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,true;
Xextern LVAL s_evalhook,s_applyhook;
Xextern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* external routines */
Xextern LVAL xlxeval();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL defun();
XFORWARD LVAL makesymbol();
X
X/* xeval - the built-in function 'eval' */
XLVAL xeval()
X{
X    LVAL expr;
X
X    /* get the expression to evaluate */
X    expr = xlgetarg();
X    xllastarg();
X
X    /* evaluate the expression */
X    return (xleval(expr));
X}
X
X/* xapply - the built-in function 'apply' */
XLVAL xapply()
X{
X    LVAL fun,arglist;
X
X    /* get the function and argument list */
X    fun = xlgetarg();
X    arglist = xlgalist();
X    xllastarg();
X
X    /* apply the function to the arguments */
X    return (xlapply(pushargs(fun,arglist)));
X}
X
X/* xfuncall - the built-in function 'funcall' */
XLVAL xfuncall()
X{
X    LVAL *newfp;
X    int argc;
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(xlgetarg());
X    pusharg(NIL); /* will be argc */
X
X    /* push each argument */
X    for (argc = 0; moreargs(); ++argc)
X    pusharg(nextarg());
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* apply the function to the arguments */
X    return (xlapply(argc));
X}
X
X/* xmacroexpand - expand a macro call repeatedly */
XLVAL xmacroexpand()
X{
X    LVAL form;
X    form = xlgetarg();
X    xllastarg();
X    return (xlexpandmacros(form));
X}
X
X/* x1macroexpand - expand a macro call */
XLVAL x1macroexpand()
X{
X    LVAL form,fun,args;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fun);
X    xlsave(args);
X
X    /* get the form */
X    form = xlgetarg();
X    xllastarg();
X
X    /* expand until the form isn't a macro call */
X    if (consp(form)) {
X    fun = car(form);        /* get the macro name */
X    args = cdr(form);        /* get the arguments */
X    if (symbolp(fun) && fboundp(fun)) {
X        fun = xlgetfunction(fun);    /* get the expansion function */
X        macroexpand(fun,args,&form);
X    }
X    }
X
X    /* restore the stack and return the expansion */
X    xlpopn(2);
X    return (form);
X}
X
X/* xatom - is this an atom? */
XLVAL xatom()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (atom(arg) ? true : NIL);
X}
X
X/* xsymbolp - is this an symbol? */
XLVAL xsymbolp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (arg == NIL || symbolp(arg) ? true : NIL);
X}
X
X/* xnumberp - is this a number? */
XLVAL xnumberp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (fixp(arg) || floatp(arg) ? true : NIL);
X}
X
X/* xintegerp - is this an integer? */
XLVAL xintegerp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (fixp(arg) ? true : NIL);
X}
X
X/* xfloatp - is this a float? */
XLVAL xfloatp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (floatp(arg) ? true : NIL);
X}
X
X/* xcharp - is this a character? */
XLVAL xcharp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (charp(arg) ? true : NIL);
X}
X
X/* xstringp - is this a string? */
XLVAL xstringp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (stringp(arg) ? true : NIL);
X}
X
X/* xarrayp - is this an array? */
XLVAL xarrayp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (vectorp(arg) ? true : NIL);
X}
X
X/* xstreamp - is this a stream? */
XLVAL xstreamp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (streamp(arg) || ustreamp(arg) ? true : NIL);
X}
X
X/* xobjectp - is this an object? */
XLVAL xobjectp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (objectp(arg) ? true : NIL);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XLVAL xboundp()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (boundp(sym) ? true : NIL);
X}
X
X/* xfboundp - is this a functional value bound to this symbol? */
XLVAL xfboundp()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (fboundp(sym) ? true : NIL);
X}
X
X/* xnull - is this null? */
XLVAL xnull()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (null(arg) ? true : NIL);
X}
X
X/* xlistp - is this a list? */
XLVAL xlistp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (listp(arg) ? true : NIL);
X}
X
X/* xendp - is this the end of a list? */
XLVAL xendp()
X{
X    LVAL arg;
X    arg = xlgalist();
X    xllastarg();
X    return (null(arg) ? true : NIL);
X}
X
X/* xconsp - is this a cons? */
XLVAL xconsp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (consp(arg) ? true : NIL);
X}
X
X/* xeq - are these equal? */
XLVAL xeq()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (arg1 == arg2 ? true : NIL);
X}
X
X/* xeql - are these equal? */
XLVAL xeql()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (eql(arg1,arg2) ? true : NIL);
X}
X
X/* xequal - are these equal? (recursive) */
XLVAL xequal()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (equal(arg1,arg2) ? true : NIL);
X}
X
X/* xset - built-in function set */
XLVAL xset()
X{
X    LVAL sym,val;
X
X    /* get the symbol and new value */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X
X    /* assign the symbol the value of argument 2 and the return value */
X    setvalue(sym,val);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xgensym - generate a symbol */
XLVAL xgensym()
X{
X    char sym[STRMAX+11]; /* enough space for prefix and number */
X    LVAL x;
X
X    /* get the prefix or number */
X    if (moreargs()) {
X    x = xlgetarg();
X    switch (ntype(x)) {
X    case SYMBOL:
X        x = getpname(x);
X    case STRING:
X        strncpy(gsprefix,getstring(x),STRMAX);
X        gsprefix[STRMAX] = '\0';
X        break;
X    case FIXNUM:
X        gsnumber = getfixnum(x);
X        break;
X    default:
X        xlerror("bad argument type",x);
X    }
X    }
X    xllastarg();
X
X    /* create the pname of the new symbol */
X    sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X    /* make a symbol with this print name */
X    return (xlmakesym(sym));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XLVAL xmakesymbol()
X{
X    return (makesymbol(FALSE));
X}
X
X/* xintern - make a new interned symbol */
XLVAL xintern()
X{
X    return (makesymbol(TRUE));
X}
X
X/* makesymbol - make a new symbol */
XLOCAL LVAL makesymbol(iflag)
X  int iflag;
X{
X    LVAL pname;
X
X    /* get the print name of the symbol to intern */
X    pname = xlgastring();
X    xllastarg();
X
X    /* make the symbol */
X    return (iflag ? xlenter(getstring(pname))
X              : xlmakesym(getstring(pname)));
X}
X
X/* xsymname - get the print name of a symbol */
XLVAL xsymname()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* return the print name */
X    return (getpname(sym));
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* get the global value */
X    while ((val = getvalue(sym)) == s_unbound)
X    xlunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymfunction - get the functional value of a symbol */
XLVAL xsymfunction()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* get the global value */
X    while ((val = getfunction(sym)) == s_unbound)
X    xlfunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* return the property list */
X    return (getplist(sym));
X}
X
X/* xget - get the value of a property */
XLVAL xget()
X{
X    LVAL sym,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* retrieve the property value */
X    return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XLVAL xputprop()
X{
X    LVAL sym,val,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* set the property value */
X    xlputprop(sym,val,prp);
X
X    /* return the value */
X    return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XLVAL xremprop()
X{
X    LVAL sym,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* remove the property */
X    xlremprop(sym,prp);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xhash - compute the hash value of a string or symbol */
XLVAL xhash()
X{
X    unsigned char *str;
X    LVAL len,val;
X    int n;
X
X    /* get the string and the table length */
X    val = xlgetarg();
X    len = xlgafixnum(); n = (int)getfixnum(len);
X    xllastarg();
X
X    /* get the string */
X    if (symbolp(val))
X    str = getstring(getpname(val));
X    else if (stringp(val))
X    str = getstring(val);
X    else
X    xlerror("bad argument type",val);
X
X    /* return the hash index */
X    return (cvfixnum((FIXTYPE)hash(str,n)));
X}
X
X/* xaref - array reference function */
XLVAL xaref()
X{
X    LVAL array,index;
X    int i;
X
X    /* get the array and the index */
X    array = xlgavector();
X    index = xlgafixnum(); i = (int)getfixnum(index);
X    xllastarg();
X
X    /* range check the index */
X    if (i < 0 || i >= getsize(array))
X    xlerror("array index out of bounds",index);
X
X    /* return the array element */
X    return (getelement(array,i));
X}
X
X/* xmkarray - make a new array */
XLVAL xmkarray()
X{
X    LVAL size;
X    int n;
X
X    /* get the size of the array */
X    size = xlgafixnum() ; n = (int)getfixnum(size);
X    xllastarg();
X
X    /* create the array */
X    return (newvector(n));
X}
X
X/* xvector - make a vector */
XLVAL xvector()
X{
X    LVAL val;
X    int i;
X
X    /* make the vector */
X    val = newvector(xlargc);
X
X    /* store each argument */
X    for (i = 0; moreargs(); ++i)
X    setelement(val,i,nextarg());
X    xllastarg();
X
X    /* return the vector */
X    return (val);
X}
X
X/* xerror - special form 'error' */
XLVAL xerror()
X{
X    LVAL emsg,arg;
X
X    /* get the error message and the argument */
X    emsg = xlgastring();
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* signal the error */
X    xlerror(getstring(emsg),arg);
X}
X
X/* xcerror - special form 'cerror' */
XLVAL xcerror()
X{
X    LVAL cmsg,emsg,arg;
X
X    /* get the correction message, the error message, and the argument */
X    cmsg = xlgastring();
X    emsg = xlgastring();
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* signal the error */
X    xlcerror(getstring(cmsg),getstring(emsg),arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xbreak - special form 'break' */
XLVAL xbreak()
X{
X    LVAL emsg,arg;
X
X    /* get the error message */
X    emsg = (moreargs() ? xlgastring() : NIL);
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* enter the break loop */
X    xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xcleanup - special form 'clean-up' */
XLVAL xcleanup()
X{
X    xllastarg();
X    xlcleanup();
X}
X
X/* xtoplevel - special form 'top-level' */
XLVAL xtoplevel()
X{
X    xllastarg();
X    xltoplevel();
X}
X
X/* xcontinue - special form 'continue' */
XLVAL xcontinue()
X{
X    xllastarg();
X    xlcontinue();
X}
X
X/* xevalhook - eval hook function */
XLVAL xevalhook()
X{
X    LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X    xlsave(newenv);
X
X    /* get the expression, the new hook functions and the environment */
X    expr = xlgetarg();
X    newehook = xlgetarg();
X    newahook = xlgetarg();
X    newenv = (moreargs() ? xlgalist() : NIL);
X    xllastarg();
X
X    /* bind *evalhook* and *applyhook* to the hook functions */
X    olddenv = xldenv;
X    xldbind(s_evalhook,newehook);
X    xldbind(s_applyhook,newahook);
X
X    /* establish the environment for the hook function */
X    if (newenv) {
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = car(newenv);
X    xlfenv = cdr(newenv);
X    }
X
X    /* evaluate the expression (bypassing *evalhook*) */
X    val = xlxeval(expr);
X
X    /* restore the old environment */
X    xlunbind(olddenv);
X    if (newenv) {
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X    }
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the result */
X    return (val);
X}
X
SHAR_EOF
if test 12891 -ne "`wc -c 'xlbfun.c'`"
then
    echo shar: error transmitting "'xlbfun.c'" '(should have been 12891 characters)'
fi
echo shar: extracting "'xlcont.c'" '(28157 characters)'
if test -f 'xlcont.c'
then
    echo shar: over-writing existing file "'xlcont.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlcont.c'
X/* xlcont - xlisp special forms */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue;
Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get;
Xextern LVAL s_svalue,s_sfunction,s_splist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern LVAL true;
X
X/* external routines */
Xextern LVAL makearglist();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL let();
XFORWARD LVAL flet();
XFORWARD LVAL prog();
XFORWARD LVAL progx();
XFORWARD LVAL doloop();
XFORWARD LVAL evarg();
XFORWARD LVAL match();
XFORWARD LVAL evmatch();
X
X/* dummy node type for a list */
X#define LIST    -1
X
X/* xquote - special form 'quote' */
XLVAL xquote()
X{
X    LVAL val;
X    val = xlgetarg();
X    xllastarg();
X    return (val);
X}
X
X/* xfunction - special form 'function' */
XLVAL xfunction()
X{
X    LVAL val;
X
X    /* get the argument */
X    val = xlgetarg();
X    xllastarg();
X
X    /* create a closure for lambda expressions */
X    if (consp(val) && car(val) == s_lambda && consp(cdr(val)))
X    val = xlclose(NIL,s_lambda,car(cdr(val)),cdr(cdr(val)),xlenv,xlfenv);
X
X    /* otherwise, get the value of a symbol */
X    else if (symbolp(val))
X    val = xlgetfunction(val);
X
X    /* otherwise, its an error */
X    else
X    xlerror("not a function",val);
X
X    /* return the function */
X    return (val);
X}
X
X/* xbquote - back quote special form */
XLVAL xbquote()
X{
X    LVAL expr;
X
X    /* get the expression */
X    expr = xlgetarg();
X    xllastarg();
X
X    /* fill in the template */
X    return (bquote1(expr));
X}
X
X/* bquote1 - back quote helper function */
XLOCAL LVAL bquote1(expr)
X  LVAL expr;
X{
X    LVAL val,list,last,new;
X
X    /* handle atoms */
X    if (atom(expr))
X    val = expr;
X
X    /* handle (comma <expr>) */
X    else if (car(expr) == s_comma) {
X    if (atom(cdr(expr)))
X        xlfail("bad comma expression");
X    val = xleval(car(cdr(expr)));
X    }
X
X    /* handle ((comma-at <expr>) ... ) */
X    else if (consp(car(expr)) && car(car(expr)) == s_comat) {
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(val);
X    if (atom(cdr(car(expr))))
X        xlfail("bad comma-at expression");
X    list = xleval(car(cdr(car(expr))));
X    for (last = NIL; consp(list); list = cdr(list)) {
X        new = consa(car(list));
X        if (last)
X        rplacd(last,new);
X        else
X        val = new;
X        last = new;
X    }
X    if (last)
X        rplacd(last,bquote1(cdr(expr)));
X    else
X        val = bquote1(cdr(expr));
X    xlpopn(2);
X    }
X
X    /* handle any other list */
X    else {
X    xlsave1(val);
X    val = consa(NIL);
X    rplaca(val,bquote1(car(expr)));
X    rplacd(val,bquote1(cdr(expr)));
X    xlpop();
X    }
X
X    /* return the result */
X    return (val);
X}
X
X/* xlambda - special form 'lambda' */
XLVAL xlambda()
X{
X    LVAL fargs,arglist,val;
X
X    /* get the formal argument list and function body */
X    xlsave1(arglist);
X    fargs = xlgalist();
X    arglist = makearglist(xlargc,xlargv);
X
X    /* create a new function definition */
X    val = xlclose(NIL,s_lambda,fargs,arglist,xlenv,xlfenv);
X
X    /* restore the stack and return the closure */
X    xlpop();
X    return (val);
X}
X
X/* xgetlambda - get the lambda expression associated with a closure */
XLVAL xgetlambda()
X{
X    LVAL closure;
X    closure = xlgaclosure();
X    return (cons(gettype(closure),
X                 cons(getlambda(closure),getbody(closure))));
X}
X
X/* xsetq - special form 'setq' */
XLVAL xsetq()
X{
X    LVAL sym,val;
X
X    /* handle each pair of arguments */
X    for (val = NIL; moreargs(); ) {
X    sym = xlgasymbol();
X    val = xleval(nextarg());
X    xlsetvalue(sym,val);
X    }
X
X    /* return the result value */
X    return (val);
X}
X
X/* xpsetq - special form 'psetq' */
XLVAL xpsetq()
X{
X    LVAL plist,sym,val;
X
X    /* protect some pointers */
X    xlsave1(plist);
X
X    /* handle each pair of arguments */
X    for (val = NIL; moreargs(); ) {
X    sym = xlgasymbol();
X    val = xleval(nextarg());
X    plist = cons(cons(sym,val),plist);
X    }
X
X    /* do parallel sets */
X    for (; plist; plist = cdr(plist))
X    xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result value */
X    return (val);
X}
X
X/* xsetf - special form 'setf' */
XLVAL xsetf()
X{
X    LVAL place,value;
X
X    /* protect some pointers */
X    xlsave1(value);
X
X    /* handle each pair of arguments */
X    while (moreargs()) {
X
X    /* get place and value */
X    place = xlgetarg();
X    value = xleval(nextarg());
X
X    /* expand macros in the place form */
X    if (consp(place))
X        place = xlexpandmacros(place);
X
X    /* check the place form */
X    if (symbolp(place))
X        xlsetvalue(place,value);
X    else if (consp(place))
X        placeform(place,value);
X    else
X        xlfail("bad place form");
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (value);
X}
X
X/* placeform - handle a place form other than a symbol */
XLOCAL placeform(place,value)
X  LVAL place,value;
X{
X    LVAL fun,arg1,arg2;
X    int i;
X
X    /* check the function name */
X    if ((fun = match(SYMBOL,&place)) == s_get) {
X    xlstkcheck(2);
X    xlsave(arg1);
X    xlsave(arg2);
X    arg1 = evmatch(SYMBOL,&place);
X    arg2 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    xlputprop(arg1,value,arg2);
X    xlpopn(2);
X    }
X    else if (fun == s_svalue) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setvalue(arg1,value);
X    }
X    else if (fun == s_sfunction) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setfunction(arg1,value);
X    }
X    else if (fun == s_splist) {
X    arg1 = evmatch(SYMBOL,&place);
X    if (place) toomany(place);
X    setplist(arg1,value);
X    }
X    else if (fun == s_car) {
X    arg1 = evmatch(CONS,&place);
X    if (place) toomany(place);
X    rplaca(arg1,value);
X    }
X    else if (fun == s_cdr) {
X    arg1 = evmatch(CONS,&place);
X    if (place) toomany(place);
X    rplacd(arg1,value);
X    }
X    else if (fun == s_nth) {
X    xlsave1(arg1);
X    arg1 = evmatch(FIXNUM,&place);
X    arg2 = evmatch(LIST,&place);
X    if (place) toomany(place);
X    for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
X        arg2 = cdr(arg2);
X    if (consp(arg2))
X        rplaca(arg2,value);
X    xlpop();
X    }
X    else if (fun == s_aref) {
X    xlsave1(arg1);
X    arg1 = evmatch(VECTOR,&place);
X    arg2 = evmatch(FIXNUM,&place); i = (int)getfixnum(arg2);
X    if (place) toomany(place);
X    if (i < 0 || i >= getsize(arg1))
X        xlerror("index out of range",arg2);
X    setelement(arg1,i,value);
X    xlpop();
X    }
X    else if (fun = xlgetprop(fun,s_setf))
X    setffunction(fun,place,value);
X    else
X    xlfail("bad place form");
X}
X
X/* setffunction - call a user defined setf function */
XLOCAL setffunction(fun,place,value)
X  LVAL fun,place,value;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL);
X
X    /* push the values of all of the place expressions and the new value */
X    for (argc = 1; consp(place); place = cdr(place), ++argc)
X    pusharg(xleval(car(place)));
X    pusharg(value);
X
X    /* insert the argument count and establish the call frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* apply the function */
X    xlapply(argc);
X}
X
X/* xdefun - special form 'defun' */
XLVAL xdefun()
X{
X    LVAL sym,fargs,arglist;
X
X    /* get the function symbol and formal argument list */
X    xlsave1(arglist);
X    sym = xlgasymbol();
X    fargs = xlgalist();
X    arglist = makearglist(xlargc,xlargv);
X
X    /* make the symbol point to a new function definition */
X    xlsetfunction(sym,xlclose(sym,s_lambda,fargs,arglist,xlenv,xlfenv));
X
X    /* restore the stack and return the function symbol */
X    xlpop();
X    return (sym);
X}
X
X/* xdefmacro - special form 'defmacro' */
XLVAL xdefmacro()
X{
X    LVAL sym,fargs,arglist;
X
X    /* get the function symbol and formal argument list */
X    xlsave1(arglist);
X    sym = xlgasymbol();
X    fargs = xlgalist();
X    arglist = makearglist(xlargc,xlargv);
X
X    /* make the symbol point to a new function definition */
X    xlsetfunction(sym,xlclose(sym,s_macro,fargs,arglist,NIL,NIL));
X
X    /* restore the stack and return the function symbol */
X    xlpop();
X    return (sym);
X}
X
X/* xcond - special form 'cond' */
XLVAL xcond()
X{
X    LVAL list,val;
X
X    /* find a predicate that is true */
X    for (val = NIL; moreargs(); ) {
X
X    /* get the next conditional */
X    list = nextarg();
X
X    /* evaluate the predicate part */
X    if (consp(list) && (val = xleval(car(list)))) {
X
X        /* evaluate each expression */
X        for (list = cdr(list); consp(list); list = cdr(list))
X        val = xleval(car(list));
X
X        /* exit the loop */
X        break;
X    }
X    }
X
X    /* return the value */
X    return (val);
X}
X
X/* xwhen - special form 'when' */
XLVAL xwhen()
X{
X    LVAL val;
X
X    /* check the test expression */
X    if (val = xleval(xlgetarg()))
X    while (moreargs())
X        val = xleval(nextarg());
X
X    /* return the value */
X    return (val);
X}
X
X/* xunless - special form 'unless' */
XLVAL xunless()
X{
X    LVAL val=NIL;
X
X    /* check the test expression */
X    if (xleval(xlgetarg()) == NIL)
X    while (moreargs())
X        val = xleval(nextarg());
X
X    /* return the value */
X    return (val);
X}
X
X/* xcase - special form 'case' */
XLVAL xcase()
X{
X    LVAL key,list,cases,val;
X
X    /* protect some pointers */
X    xlsave1(key);
X
X    /* get the key expression */
X    key = xleval(nextarg());
X
X    /* find a case that matches */
X    for (val = NIL; moreargs(); ) {
X
X    /* get the next case clause */
X    list = nextarg();
X
X    /* make sure this is a valid clause */
X    if (consp(list)) {
X
X        /* compare the key list against the key */
X        if ((cases = car(list)) == true ||
X                (listp(cases) && keypresent(key,cases)) ||
X                eql(key,cases)) {
X
X        /* evaluate each expression */
X        for (list = cdr(list); consp(list); list = cdr(list))
X            val = xleval(car(list));
X
X        /* exit the loop */
X        break;
X        }
X    }
X    else
X        xlerror("bad case clause",list);
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (val);
X}
X
X/* keypresent - check for the presence of a key in a list */
XLOCAL int keypresent(key,list)
X  LVAL key,list;
X{
X    for (; consp(list); list = cdr(list))
X    if (eql(car(list),key))
X        return (TRUE);
X    return (FALSE);
X}
X
X/* xand - special form 'and' */
XLVAL xand()
X{
X    LVAL val;
X
X    /* evaluate each argument */
X    for (val = true; moreargs(); )
X    if ((val = xleval(nextarg())) == NIL)
X        break;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xor - special form 'or' */
XLVAL xor()
X{
X    LVAL val;
X
X    /* evaluate each argument */
X    for (val = NIL; moreargs(); )
X    if ((val = xleval(nextarg())))
X        break;
X
X    /* return the result value */
X    return (val);
X}
X
X/* xif - special form 'if' */
XLVAL xif()
X{
X    LVAL testexpr,thenexpr,elseexpr;
X
X    /* get the test expression, then clause and else clause */
X    testexpr = xlgetarg();
X    thenexpr = xlgetarg();
X    elseexpr = (moreargs() ? xlgetarg() : NIL);
X    xllastarg();
X
X    /* evaluate the appropriate clause */
X    return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
X}
X
X/* xlet - special form 'let' */
XLVAL xlet()
X{
X    return (let(TRUE));
X}
X
X/* xletstar - special form 'let*' */
XLVAL xletstar()
X{
X    return (let(FALSE));
X}
X
X/* let - common let routine */
XLOCAL LVAL let(pflag)
X  int pflag;
X{
X    LVAL newenv,val;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(xlgalist(),newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the code */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xflet - built-in function 'flet' */
XLVAL xflet()
X{
X    return (flet(s_lambda,TRUE));
X}
X
X/* xlabels - built-in function 'labels' */
XLVAL xlabels()
X{
X    return (flet(s_lambda,FALSE));
X}
X
X/* xmacrolet - built-in function 'macrolet' */
XLVAL xmacrolet()
X{
X    return (flet(s_macro,TRUE));
X}
X
X/* flet - common flet/labels/macrolet routine */
XLOCAL LVAL flet(type,letflag)
X  LVAL type; int letflag;
X{
X    LVAL list,bnd,sym,fargs,val;
X
X    /* create a new environment frame */
X    xlfenv = xlframe(xlfenv);
X
X    /* bind each symbol in the list of bindings */
X    for (list = xlgalist(); consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* get the symbol and the function definition */
X    sym = match(SYMBOL,&bnd);
X    fargs = match(LIST,&bnd);
X    val = xlclose(sym,type,fargs,bnd,xlenv,(letflag?cdr(xlfenv):xlfenv));
X
X    /* bind the value to the symbol */
X    xlfbind(sym,val);
X    }
X
X    /* execute the code */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* unbind the arguments */
X    xlfenv = cdr(xlfenv);
X
X    /* return the result */
X    return (val);
X}
X
X/* xprog - special form 'prog' */
XLVAL xprog()
X{
X    return (prog(TRUE));
X}
X
X/* xprogstar - special form 'prog*' */
XLVAL xprogstar()
X{
X    return (prog(FALSE));
X}
X
X/* prog - common prog routine */
XLOCAL LVAL prog(pflag)
X  int pflag;
X{
X    LVAL newenv,val;
X    CONTEXT cntxt;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* get the list of bindings and bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(xlgalist(),newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the code */
X    tagbody();
X    val = NIL;
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xgo - special form 'go' */
XLVAL xgo()
X{
X    LVAL label;
X
X    /* get the target label */
X    label = xlgetarg();
X    xllastarg();
X
X    /* transfer to the label */
X    xlgo(label);
X}
X
X/* xreturn - special form 'return' */
XLVAL xreturn()
X{
X    LVAL val;
X
X    /* get the return value */
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* return from the inner most block */
X    xlreturn(NIL,val);
X}
X
X/* xrtnfrom - special form 'return-from' */
XLVAL xrtnfrom()
X{
X    LVAL name,val;
X
X    /* get the return value */
X    name = xlgasymbol();
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* return from the inner most block */
X    xlreturn(name,val);
X}
X
X/* xprog1 - special form 'prog1' */
XLVAL xprog1()
X{
X    return (progx(1));
X}
X
X/* xprog2 - special form 'prog2' */
XLVAL xprog2()
X{
X    return (progx(2));
X}
X
X/* progx - common progx code */
XLOCAL LVAL progx(n)
X  int n;
X{
X    LVAL val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* evaluate the first n expressions */
X    while (moreargs() && --n >= 0)
X    val = xleval(nextarg());
X
X    /* evaluate each remaining argument */
X    while (moreargs())
X    xleval(nextarg());
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xprogn - special form 'progn' */
XLVAL xprogn()
X{
X    LVAL val;
X
X    /* evaluate each expression */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xprogv - special form 'progv' */
XLVAL xprogv()
X{
X    LVAL olddenv,vars,vals,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(vars);
X    xlsave(vals);
X
X    /* get the list of variables and the list of values */
X    vars = xlgalist(); vars = xleval(vars);
X    vals = xlgalist(); vals = xleval(vals);
X
X    /* bind the values to the variables */
X    for (olddenv = xldenv; consp(vars); vars = cdr(vars)) {
X    if (!symbolp(car(vars)))
X        xlerror("expecting a symbol",car(vars));
X    if (consp(vals)) {
X        xldbind(car(vars),car(vals));
X        vals = cdr(vals);
X    }
X    else
X        xldbind(car(vars),s_unbound);
X    }
X
X    /* evaluate each expression */
X    for (val = NIL; moreargs(); )
X    val = xleval(nextarg());
X
X    /* restore the previous environment and the stack */
X    xlunbind(olddenv);
X    xlpopn(2);
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xloop - special form 'loop' */
XLVAL xloop()
X{
X    LVAL *argv,arg,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (argv = xlargv, argc = xlargc; ; xlargv = argv, xlargc = argc)
X        while (moreargs()) {
X        arg = nextarg();
X        if (consp(arg))
X            xleval(arg);
X        }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdo - special form 'do' */
XLVAL xdo()
X{
X    return (doloop(TRUE));
X}
X
X/* xdostar - special form 'do*' */
XLVAL xdostar()
X{
X    return (doloop(FALSE));
X}
X
X/* doloop - common do routine */
XLOCAL LVAL doloop(pflag)
X  int pflag;
X{
X    LVAL newenv,*argv,blist,clist,test,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(newenv);
X
X    /* get the list of bindings, the exit test and the result forms */
X    blist = xlgalist();
X    clist = xlgalist();
X    test = (consp(clist) ? car(clist) : NIL);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* create a new environment frame */
X    newenv = xlframe(xlenv);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* bind the symbols */
X    if (!pflag) xlenv = newenv;
X    dobindings(blist,newenv);
X    if (pflag) xlenv = newenv;
X
X    /* execute the loop as long as the test is false */
X    for (val = NIL; xleval(test) == NIL; doupdates(blist,pflag)) {
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    if (consp(clist))
X        for (clist = cdr(clist); consp(clist); clist = cdr(clist))
X        val = xleval(car(clist));
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdolist - special form 'dolist' */
XLVAL xdolist()
X{
X    LVAL list,*argv,clist,sym,val;
X    CONTEXT cntxt;
X    int argc;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* get the control list (sym list result-expr) */
X    clist = xlgalist();
X    sym = match(SYMBOL,&clist);
X    list = evmatch(LIST,&clist);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym,NIL);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* loop through the list */
X    for (val = NIL; consp(list); list = cdr(list)) {
X
X        /* bind the symbol to the next list element */
X        xlsetvalue(sym,car(list));
X
X        /* execute the loop body */
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    xlsetvalue(sym,NIL);
X    val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xdotimes - special form 'dotimes' */
XLVAL xdotimes()
X{
X    LVAL *argv,clist,sym,cnt,val;
X    CONTEXT cntxt;
X    int argc,n,i;
X
X    /* get the control list (sym list result-expr) */
X    clist = xlgalist();
X    sym = match(SYMBOL,&clist);
X    cnt = evmatch(FIXNUM,&clist); n = getfixnum(cnt);
X    argv = xlargv;
X    argc = xlargc;
X
X    /* initialize the local environment */
X    xlenv = xlframe(xlenv);
X    xlbind(sym,NIL);
X
X    /* establish a new execution context */
X    xlbegin(&cntxt,CF_RETURN,NIL);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else {
X
X    /* loop through for each value from zero to n-1 */
X    for (val = NIL, i = 0; i < n; ++i) {
X
X        /* bind the symbol to the next list element */
X        xlsetvalue(sym,cvfixnum((FIXTYPE)i));
X
X        /* execute the loop body */
X        xlargv = argv;
X        xlargc = argc;
X        tagbody();
X    }
X
X    /* evaluate the result expression */
X    xlsetvalue(sym,cnt);
X    val = (consp(clist) ? xleval(car(clist)) : NIL);
X
X    /* unbind the arguments */
X    xlenv = cdr(xlenv);
X    }
X    xlend(&cntxt);
X
X    /* return the result */
X    return (val);
X}
X
X/* xblock - special form 'block' */
XLVAL xblock()
X{
X    LVAL name,val;
X    CONTEXT cntxt;
X
X    /* get the block name */
X    name = xlgetarg();
X    if (name && !symbolp(name))
X    xlbadtype(name);
X
X    /* execute the block */
X    xlbegin(&cntxt,CF_RETURN,name);
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (val = NIL; moreargs(); )
X        val = xleval(nextarg());
X    xlend(&cntxt);
X
X    /* return the value of the last expression */
X    return (val);
X}
X
X/* xtagbody - special form 'tagbody' */
XLVAL xtagbody()
X{
X    tagbody();
X    return (NIL);
X}
X
X/* xcatch - special form 'catch' */
XLVAL xcatch()
X{
X    CONTEXT cntxt;
X    LVAL tag,val;
X
X    /* protect some pointers */
X    xlsave1(tag);
X
X    /* get the tag */
X    tag = xleval(nextarg());
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_THROW,tag);
X
X    /* check for 'throw' */
X    if (setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X
X    /* otherwise, evaluate the remainder of the arguments */
X    else {
X    for (val = NIL; moreargs(); )
X        val = xleval(nextarg());
X    }
X    xlend(&cntxt);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xthrow - special form 'throw' */
XLVAL xthrow()
X{
X    LVAL tag,val;
X
X    /* get the tag and value */
X    tag = xleval(nextarg());
X    val = (moreargs() ? xleval(nextarg()) : NIL);
X    xllastarg();
X
X    /* throw the tag */
X    xlthrow(tag,val);
X}
X
X/* xunwindprotect - special form 'unwind-protect' */
XLVAL xunwindprotect()
X{
X    extern CONTEXT *xltarget;
X    extern int xlmask;
X    CONTEXT cntxt,*target;
X    int mask,sts;
X    LVAL val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the expression to protect */
X    val = xlgetarg();
X
X    /* evaluate the protected expression */
X    xlbegin(&cntxt,CF_UNWIND,NIL);
X    if (sts = setjmp(cntxt.c_jmpbuf)) {
X    target = xltarget;
X    mask = xlmask;
X    val = xlvalue;
X    }
X    else
X    val = xleval(val);
X    xlend(&cntxt);
X
X    /* evaluate the cleanup expressions */
X    while (moreargs())
X    xleval(nextarg());
X
X    /* if unwinding, continue unwinding */
X    if (sts)
X    xljump(target,mask,val);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value of the protected expression */
X    return (val);
X}
X
X/* xerrset - special form 'errset' */
XLVAL xerrset()
X{
X    LVAL expr,flag,val;
X    CONTEXT cntxt;
X
X    /* get the expression and the print flag */
X    expr = xlgetarg();
X    flag = (moreargs() ? xlgetarg() : true);
X    xllastarg();
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_ERROR,flag);
X
X    /* check for error */
X    if (setjmp(cntxt.c_jmpbuf))
X    val = NIL;
X
X    /* otherwise, evaluate the expression */
X    else {
X    expr = xleval(expr);
X    val = consa(expr);
X    }
X    xlend(&cntxt);
X
X    /* return the result */
X    return (val);
X}
X
X/* xtrace - special form 'trace' */
XLVAL xtrace()
X{
X    LVAL sym,fun,this;
X
X    /* loop through all of the arguments */
X    sym = xlenter("*TRACELIST*");
X    while (moreargs()) {
X    fun = xlgasymbol();
X
X    /* check for the function name already being in the list */
X    for (this = getvalue(sym); consp(this); this = cdr(this))
X        if (car(this) == fun)
X        break;
X
X    /* add the function name to the list */
X    if (null(this))
X        setvalue(sym,cons(fun,getvalue(sym)));
X    }
X    return (getvalue(sym));
X}
X
X/* xuntrace - special form 'untrace' */
XLVAL xuntrace()
X{
X    LVAL sym,fun,this,last;
X
X    /* loop through all of the arguments */
X    sym = xlenter("*TRACELIST*");
X    while (moreargs()) {
X    fun = xlgasymbol();
X
X    /* remove the function name from the list */
X    last = NIL;
X    for (this = getvalue(sym); consp(this); this = cdr(this)) {
X        if (car(this) == fun) {
X        if (last)
X            rplacd(last,cdr(this));
X        else
X            setvalue(sym,cdr(this));
X        break;
X        }
X        last = this;
X    }
X    }
X    return (getvalue(sym));
X}
X
X/* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
XLOCAL dobindings(list,env)
X  LVAL list,env;
X{
X    LVAL bnd,sym,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* bind each symbol in the list of bindings */
X    for (; consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* handle a symbol */
X    if (symbolp(bnd)) {
X        sym = bnd;
X        val = NIL;
X    }
X
X    /* handle a list of the form (symbol expr) */
X    else if (consp(bnd)) {
X        sym = match(SYMBOL,&bnd);
X        val = evarg(&bnd);
X    }
X    else
X        xlfail("bad binding");
X
X    /* bind the value to the symbol */
X    xlpbind(sym,val,env);
X    }
X
X    /* restore the stack */
X    xlpop();
X}
X
X/* doupdates - handle updates for do/do* */
XLOCAL doupdates(list,pflag)
X  LVAL list; int pflag;
X{
X    LVAL plist,bnd,sym,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(plist);
X    xlsave(val);
X
X    /* bind each symbol in the list of bindings */
X    for (; consp(list); list = cdr(list)) {
X
X    /* get the next binding */
X    bnd = car(list);
X
X    /* handle a list of the form (symbol expr) */
X    if (consp(bnd)) {
X        sym = match(SYMBOL,&bnd);
X        bnd = cdr(bnd);
X        if (bnd) {
X        val = evarg(&bnd);
X        if (pflag)
X            plist = cons(cons(sym,val),plist);
X        else
X            xlsetvalue(sym,val);
X        }
X    }
X    }
X
X    /* set the values for parallel updates */
X    for (; plist; plist = cdr(plist))
X    xlsetvalue(car(car(plist)),cdr(car(plist)));
X
X    /* restore the stack */
X    xlpopn(2);
X}
X
X/* tagbody - execute code within a block and tagbody */
XLOCAL tagbody()
X{
X    LVAL *argv,arg;
X    CONTEXT cntxt;
X    int argc;
X
X    /* establish an execution context */
X    xlbegin(&cntxt,CF_GO,NIL);
X    argc = xlargc;
X    argv = xlargv;
X
X    /* check for a 'go' */
X    if (setjmp(cntxt.c_jmpbuf)) {
X    cntxt.c_xlargc = argc;
X    cntxt.c_xlargv = argv;
X    }
X
X    /* execute the body */
X    while (moreargs()) {
X    arg = nextarg();
X    if (consp(arg))
X        xleval(arg);
X    }
X    xlend(&cntxt);
X}
X
X/* match - get an argument and match its type */
XLOCAL LVAL match(type,pargs)
X  int type; LVAL *pargs;
X{
X    LVAL arg;
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* check its type */
X    if (type == LIST) {
X    if (arg && ntype(arg) != CONS)
X        xlerror("bad argument type",arg);
X    }
X    else {
X    if (arg == NIL || ntype(arg) != type)
X        xlerror("bad argument type",arg);
X    }
X
X    /* return the argument */
X    return (arg);
X}
X
X/* evarg - get the next argument and evaluate it */
XLOCAL LVAL evarg(pargs)
X  LVAL *pargs;
X{
X    LVAL arg;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* evaluate the argument */
X    arg = xleval(arg);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the argument */
X    return (arg);
X}
X
X/* evmatch - get an evaluated argument and match its type */
XLOCAL LVAL evmatch(type,pargs)
X  int type; LVAL *pargs;
X{
X    LVAL arg;
X
X    /* protect some pointers */
X    xlsave1(arg);
X
X    /* make sure the argument exists */
X    if (!consp(*pargs))
X    toofew(*pargs);
X
X    /* get the argument value */
X    arg = car(*pargs);
X
X    /* move the argument pointer ahead */
X    *pargs = cdr(*pargs);
X
X    /* evaluate the argument */
X    arg = xleval(arg);
X
X    /* check its type */
X    if (type == LIST) {
X    if (arg && ntype(arg) != CONS)
X        xlerror("bad argument type",arg);
X    }
X    else {
X    if (arg == NIL || ntype(arg) != type)
X        xlerror("bad argument type",arg);
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the argument */
X    return (arg);
X}
X
X/* toofew - too few arguments */
XLOCAL toofew(args)
X  LVAL args;
X{
X    xlerror("too few arguments",args);
X}
X
X/* toomany - too many arguments */
XLOCAL toomany(args)
X  LVAL args;
X{
X    xlerror("too many arguments",args);
X}
X
SHAR_EOF
if test 28157 -ne "`wc -c 'xlcont.c'`"
then
    echo shar: error transmitting "'xlcont.c'" '(should have been 28157 characters)'
fi
echo shar: extracting "'xldbug.c'" '(3992 characters)'
if test -f 'xldbug.c'
then
    echo shar: over-writing existing file "'xldbug.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
X/* xldebug - xlisp debugging support */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern int xldebug;
Xextern int xlsample;
Xextern LVAL s_debugio,s_unbound;
Xextern LVAL s_tracenable,s_tlimit,s_breakenable;
Xextern LVAL true;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD LVAL stacktop();
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X  char *emsg;
X{
X    xlsignal(emsg,s_unbound);
X    xlerrprint("error",NULL,emsg,s_unbound);
X    xlbrklevel();
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X  char *emsg; LVAL arg;
X{
X    breakloop("break","return from BREAK",emsg,arg,TRUE);
X}
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X  char *emsg;
X{
X    xlerror(emsg,s_unbound);
X}
X
X/* xlerror - handle a fatal error */
Xxlerror(emsg,arg)
X  char *emsg; LVAL arg;
X{
X    if (getvalue(s_breakenable) != NIL)
X    breakloop("error",NULL,emsg,arg,FALSE);
X    else {
X    xlsignal(emsg,arg);
X    xlerrprint("error",NULL,emsg,arg);
X    xlbrklevel();
X    }
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X  char *cmsg,*emsg; LVAL arg;
X{
X    if (getvalue(s_breakenable) != NIL)
X    breakloop("error",cmsg,emsg,arg,TRUE);
X    else {
X    xlsignal(emsg,arg);
X    xlerrprint("error",NULL,emsg,arg);
X    xlbrklevel();
X    }
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X  char *hdr,*cmsg,*emsg; LVAL arg;
X{
X    /* print the error message */
X    sprintf(buf,"%s: %s",hdr,emsg);
X    errputstr(buf);
X
X    /* print the argument */
X    if (arg != s_unbound) {
X    errputstr(" - ");
X    errprint(arg);
X    }
X
X    /* no argument, just end the line */
X    else
X    errputstr("\n");
X
X    /* print the continuation message */
X    if (cmsg) {
X    sprintf(buf,"if continued: %s\n",cmsg);
X    errputstr(buf);
X    }
X}
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X  char *hdr,*cmsg,*emsg; LVAL arg; int cflag;
X{
X    LVAL expr,val;
X    CONTEXT cntxt;
X    int type;
X
X    /* print the error message */
X    xlerrprint(hdr,cmsg,emsg,arg);
X
X    /* flush the input buffer */
X    xlflush();
X
X    /* do the back trace */
X    if (getvalue(s_tracenable)) {
X    val = getvalue(s_tlimit);
X    xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
X    }
X
X    /* protect some pointers */
X    xlsave1(expr);
X
X    /* increment the debug level */
X    ++xldebug;
X
X    /* debug command processing loop */
X    xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
X    for (type = 0; type == 0; ) {
X
X    /* setup the continue trap */
X    if (type = setjmp(cntxt.c_jmpbuf))
X        switch (type) {
X        case CF_CLEANUP:
X        continue;
X        case CF_BRKLEVEL:
X        type = 0;
X        break;
X        case CF_CONTINUE:
X        if (cflag) {
X            dbgputstr("[ continue from break loop ]\n");
X            continue;
X        }
X        else xlabort("this error can't be continued");
X        }
X
X    /* print a prompt */
X    sprintf(buf,"%d> ",xldebug);
X    dbgputstr(buf);
X
X    /* read an expression and check for eof */
X    if (!xlread(getvalue(s_debugio),&expr,FALSE)) {
X        type = CF_CLEANUP;
X        break;
X    }
X
X    /* save the input expression */
X    xlrdsave(expr);
X
X    /* evaluate the expression */
X    expr = xleval(expr);
X
X    /* save the result */
X    xlevsave(expr);
X
X    /* print it */
X    dbgprint(expr);
X    }
X    xlend(&cntxt);
X
X    /* decrement the debug level */
X    --xldebug;
X
X    /* restore the stack */
X    xlpop();
X
X    /* check for aborting to the previous level */
X    if (type == CF_CLEANUP)
X    xlbrklevel();
X}
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X  int n;
X{
X    LVAL *fp,*p;
X    int argc;
X    for (fp = xlfp; (n < 0 || n--) && *fp; fp = fp - (int)getfixnum(*fp)) {
X    p = fp + 1;
X    errputstr("Function: ");
X    errprint(*p++);
X    if (argc = (int)getfixnum(*p++))
X        errputstr("Arguments:\n");
X    while (--argc >= 0) {
X        errputstr("  ");
X        errprint(*p++);
X    }
X    }
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X    xlsample = 0;
X    xldebug = 0;
X}
X
SHAR_EOF
if test 3992 -ne "`wc -c 'xldbug.c'`"
then
    echo shar: error transmitting "'xldbug.c'" '(should have been 3992 characters)'
fi
echo shar: extracting "'xldmem.c'" '(14715 characters)'
if test -f 'xldmem.c'
then
    echo shar: over-writing existing file "'xldmem.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.c'
X/* xldmem - xlisp dynamic memory management routines */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* node flags */
X#define MARK    1
X#define LEFT    2
X
X/* macro to compute the size of a segment */
X#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
X
X/* external variables */
Xextern LVAL obarray,s_gcflag,s_gchook,s_unbound,true;
Xextern LVAL xlenv,xlfenv,xldenv;
Xextern char buf[];
X
X/* variables local to xldmem.c and xlimage.c */
XSEGMENT *segs,*lastseg,*fixseg,*charseg;
Xint anodes,nsegs,gccalls;
Xlong nnodes,nfree,total;
XLVAL fnodes;
X
X/* external procedures */
Xextern char *malloc();
Xextern char *calloc();
X
X/* forward declarations */
XFORWARD LVAL newnode();
XFORWARD unsigned char *stralloc();
XFORWARD SEGMENT *newsegment();
X
X/* cons - construct a new cons node */
XLVAL cons(x,y)
X  LVAL x,y;
X{
X    LVAL nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NIL) {
X    xlstkcheck(2);
X    xlprotect(x);
X    xlprotect(y);
X    findmem();
X    if ((nnode = fnodes) == NIL)
X        xlabort("insufficient node space");
X    xlpop();
X    xlpop();
X    }
X
X    /* unlink the node from the free list */
X    fnodes = cdr(nnode);
X    --nfree;
X
X    /* initialize the new node */
X    nnode->n_type = CONS;
X    rplaca(nnode,x);
X    rplacd(nnode,y);
X
X    /* return the new node */
X    return (nnode);
X}
X
X/* cvstring - convert a string to a string node */
XLVAL cvstring(str)
X  char *str;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newnode(STRING);
X    val->n_strlen = strlen(str) + 1;
X    val->n_string = stralloc(getslength(val));
X    strcpy(getstring(val),str);
X    xlpop();
X    return (val);
X}
X
X/* newstring - allocate and initialize a new string */
XLVAL newstring(size)
X  int size;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newnode(STRING);
X    val->n_strlen = size;
X    val->n_string = stralloc(getslength(val));
X    strcpy(getstring(val),"");
X    xlpop();
X    return (val);
X}
X
X/* cvsymbol - convert a string to a symbol */
XLVAL cvsymbol(pname)
X  char *pname;
X{
X    LVAL val;
X    xlsave1(val);
X    val = newvector(SYMSIZE);
X    val->n_type = SYMBOL;
X    setvalue(val,s_unbound);
X    setfunction(val,s_unbound);
X    setpname(val,cvstring(pname));
X    xlpop();
X    return (val);
X}
X
X/* cvsubr - convert a function to a subr or fsubr */
XLVAL cvsubr(fcn,type,offset)
X  LVAL (*fcn)(); int type,offset;
X{
X    LVAL val;
X    val = newnode(type);
X    val->n_subr = fcn;
X    val->n_offset = offset;
X    return (val);
X}
X
X/* cvfile - convert a file pointer to a stream */
XLVAL cvfile(fp)
X  FILE *fp;
X{
X    LVAL val;
X    val = newnode(STREAM);
X    setfile(val,fp);
X    setsavech(val,'\0');
X    return (val);
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XLVAL cvfixnum(n)
X  FIXTYPE n;
X{
X    LVAL val;
X    if (n >= SFIXMIN && n <= SFIXMAX)
X    return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
X    val = newnode(FIXNUM);
X    val->n_fixnum = n;
X    return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XLVAL cvflonum(n)
X  FLOTYPE n;
X{
X    LVAL val;
X    val = newnode(FLONUM);
X    val->n_flonum = n;
X    return (val);
X}
X
X/* cvchar - convert an integer to a character node */
XLVAL cvchar(n)
X  int n;
X{
X    if (n >= CHARMIN && n <= CHARMAX)
X    return (&charseg->sg_nodes[n-CHARMIN]);
X    xlerror("character code out of range",cvfixnum((FIXTYPE)n));
X}
X
X/* newustream - create a new unnamed stream */
XLVAL newustream()
X{
X    LVAL val;
X    val = newnode(USTREAM);
X    sethead(val,NIL);
X    settail(val,NIL);
X    return (val);
X}
X
X/* newobject - allocate and initialize a new object */
XLVAL newobject(cls,size)
X  LVAL cls; int size;
X{
X    LVAL val;
X    val = newvector(size+1);
X    val->n_type = OBJECT;
X    setelement(val,0,cls);
X    return (val);
X}
X
X/* newclosure - allocate and initialize a new closure */
XLVAL newclosure(name,type,env,fenv)
X  LVAL name,type,env,fenv;
X{
X    LVAL val;
X    val = newvector(CLOSIZE);
X    val->n_type = CLOSURE;
X    setname(val,name);
X    settype(val,type);
X    setenv(val,env);
X    setfenv(val,fenv);
X    return (val);
X}
X
X/* newstruct - allocate and initialize a new structure node */
XLVAL newstruct(type,size)
X  LVAL type; int size;
X{
X    LVAL val;
X    val = newvector(size+1);
X    val->n_type = STRUCT;
X    setelement(val,0,type);
X    return (val);
X}
X
X/* newvector - allocate and initialize a new vector node */
XLVAL newvector(size)
X  int size;
X{
X    LVAL vect;
X    int bsize;
X    xlsave1(vect);
X    vect = newnode(VECTOR);
X    vect->n_vsize = 0;
X    if (bsize = size * sizeof(LVAL)) {
X    if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
X        findmem();
X        if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
X        xlfail("insufficient vector space");
X    }
X    vect->n_vsize = size;
X    total += (long) bsize;
X    }
X    xlpop();
X    return (vect);
X}
X
X/* newnode - allocate a new node */
XLOCAL LVAL newnode(type)
X  int type;
X{
X    LVAL nnode;
X
X    /* get a free node */
X    if ((nnode = fnodes) == NIL) {
X    findmem();
X    if ((nnode = fnodes) == NIL)
X        xlabort("insufficient node space");
X    }
X
X    /* unlink the node from the free list */
X    fnodes = cdr(nnode);
X    nfree -= 1L;
X
X    /* initialize the new node */
X    nnode->n_type = type;
X    rplacd(nnode,NIL);
X
X    /* return the new node */
X    return (nnode);
X}
X
X/* stralloc - allocate memory for a string adding a byte for the terminator */
XLOCAL unsigned char *stralloc(size)
X  int size;
X{
X    unsigned char *sptr;
X
X    /* allocate memory for the string copy */
X    if ((sptr = (unsigned char *)malloc(size)) == NULL) {
X    gc();
X    if ((sptr = (unsigned char *)malloc(size)) == NULL)
X        xlfail("insufficient string space");
X    }
X    total += (long)size;
X
X    /* return the new string memory */
X    return (sptr);
X}
X
X/* findmem - find more memory by collecting then expanding */
XLOCAL findmem()
X{
X    gc();
X    if (nfree < (long)anodes)
X    addseg();
X}
X
X/* gc - garbage collect (only called here and in xlimage.c) */
Xgc()
X{
X    register LVAL **p,*ap,tmp;
X    char buf[STRMAX+1];
X    LVAL *newfp,fun;
X
X    /* print the start of the gc message */
X    if (s_gcflag && getvalue(s_gcflag)) {
X    sprintf(buf,"[ gc: total %ld, ",nnodes);
X    stdputstr(buf);
X    }
X
X    /* mark the obarray, the argument list and the current environment */
X    if (obarray)
X    mark(obarray);
X    if (xlenv)
X    mark(xlenv);
X    if (xlfenv)
X    mark(xlfenv);
X    if (xldenv)
X    mark(xldenv);
X
X    /* mark the evaluation stack */
X    for (p = xlstack; p < xlstktop; ++p)
X    if (tmp = **p)
X        mark(tmp);
X
X    /* mark the argument stack */
X    for (ap = xlargstkbase; ap < xlsp; ++ap)
X    if (tmp = *ap)
X        mark(tmp);
X
X    /* sweep memory collecting all unmarked nodes */
X    sweep();
X
X    /* count the gc call */
X    ++gccalls;
X
X    /* call the *gc-hook* if necessary */
X    if (s_gchook && (fun = getvalue(s_gchook))) {
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(cvfixnum((FIXTYPE)nnodes));
X    pusharg(cvfixnum((FIXTYPE)nfree));
X    xlfp = newfp;
X    xlapply(2);
X    }
X
X    /* print the end of the gc message */
X    if (s_gcflag && getvalue(s_gcflag)) {
X    sprintf(buf,"%ld free ]\n",nfree);
X    stdputstr(buf);
X    }
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X  LVAL ptr;
X{
X    register LVAL this,prev,tmp;
X    int type,i,n;
X
X    /* initialize */
X    prev = NIL;
X    this = ptr;
X
X    /* mark this list */
X    for (;;) {
X
X    /* descend as far as we can */
X    while (!(this->n_flags & MARK))
X
X        /* check cons and unnamed stream nodes */
X        if ((type = ntype(this)) == CONS || type == USTREAM) {
X        if (tmp = car(this)) {
X            this->n_flags |= MARK|LEFT;
X            rplaca(this,prev);
X        }
X        else if (tmp = cdr(this)) {
X            this->n_flags |= MARK;
X            rplacd(this,prev);
X        }
X        else {                /* both sides nil */
X            this->n_flags |= MARK;
X            break;
X        }
X        prev = this;            /* step down the branch */
X        this = tmp;
X        }
X
X        /* mark other node types */
X        else {
X        this->n_flags |= MARK;
X        switch (type) {
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X            for (i = 0, n = getsize(this); --n >= 0; ++i)
X            if (tmp = getelement(this,i))
X                mark(tmp);
X            break;
X        }
X        break;
X        }
X
X    /* backup to a point where we can continue descending */
X    for (;;)
X
X        /* make sure there is a previous node */
X        if (prev) {
X        if (prev->n_flags & LEFT) {    /* came from left side */
X            prev->n_flags &= ~LEFT;
X            tmp = car(prev);
X            rplaca(prev,this);
X            if (this = cdr(prev)) {
X            rplacd(prev,tmp);
X            break;
X            }
X        }
X        else {                /* came from right side */
X            tmp = cdr(prev);
X            rplacd(prev,this);
X        }
X        this = prev;            /* step back up the branch */
X        prev = tmp;
X        }
X
X        /* no previous node, must be done */
X        else
X        return;
X    }
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X    SEGMENT *seg;
X    LVAL p;
X    int n;
X
X    /* empty the free list */
X    fnodes = NIL;
X    nfree = 0L;
X
X    /* add all unmarked nodes */
X    for (seg = segs; seg; seg = seg->sg_next) {
X    if (seg == fixseg)     /* don't sweep the fixnum segment */
X        continue;
X    else if (seg == charseg) /* don't sweep the character segment */
X        continue;
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p)
X        if (!(p->n_flags & MARK)) {
X        switch (ntype(p)) {
X        case STRING:
X            if (getstring(p) != NULL) {
X                total -= (long)getslength(p);
X                free(getstring(p));
X            }
X            break;
X        case STREAM:
X            if (getfile(p))
X                osclose(getfile(p));
X            break;
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X            if (p->n_vsize) {
X                total -= (long) (p->n_vsize * sizeof(LVAL));
X                free(p->n_vdata);
X            }
X            break;
X        }
X        p->n_type = FREE;
X        rplaca(p,NIL);
X        rplacd(p,fnodes);
X        fnodes = p;
X        nfree += 1L;
X        }
X        else
X        p->n_flags &= ~MARK;
X    }
X}
X
X/* addseg - add a segment to the available memory */
XLOCAL int addseg()
X{
X    SEGMENT *newseg;
X    LVAL p;
X    int n;
X
X    /* allocate the new segment */
X    if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
X    return (FALSE);
X
X    /* add each new node to the free list */
X    p = &newseg->sg_nodes[0];
X    for (n = anodes; --n >= 0; ++p) {
X    rplacd(p,fnodes);
X    fnodes = p;
X    }
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* newsegment - create a new segment (only called here and in xlimage.c) */
XSEGMENT *newsegment(n)
X  int n;
X{
X    SEGMENT *newseg;
X
X    /* allocate the new segment */
X    if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
X    return (NULL);
X
X    /* initialize the new segment */
X    newseg->sg_size = n;
X    newseg->sg_next = NULL;
X    if (segs)
X    lastseg->sg_next = newseg;
X    else
X    segs = newseg;
X    lastseg = newseg;
X
X    /* update the statistics */
X    total += (long)segsize(n);
X    nnodes += (long)n;
X    nfree += (long)n;
X    ++nsegs;
X
X    /* return the new segment */
X    return (newseg);
X}
X
X/* stats - print memory statistics */
XLOCAL stats()
X{
X    sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
X    sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
X    sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
X    sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
X    sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
X    sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
X}
X
X/* xgc - xlisp function to force garbage collection */
XLVAL xgc()
X{
X    /* make sure there aren't any arguments */
X    xllastarg();
X
X    /* garbage collect */
X    gc();
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xexpand - xlisp function to force memory expansion */
XLVAL xexpand()
X{
X    LVAL num;
X    int n,i;
X
X    /* get the new number to allocate */
X    if (moreargs()) {
X    num = xlgafixnum();
X    n = getfixnum(num);
X    }
X    else
X    n = 1;
X    xllastarg();
X
X    /* allocate more segments */
X    for (i = 0; i < n; i++)
X    if (!addseg())
X        break;
X
X    /* return the number of segments added */
X    return (cvfixnum((FIXTYPE)i));
X}
X
X/* xalloc - xlisp function to set the number of nodes to allocate */
XLVAL xalloc()
X{
X    int n,oldn;
X    LVAL num;
X
X    /* get the new number to allocate */
X    num = xlgafixnum();
X    n = getfixnum(num);
X
X    /* make sure there aren't any more arguments */
X    xllastarg();
X
X    /* set the new number of nodes to allocate */
X    oldn = anodes;
X    anodes = n;
X
X    /* return the old number */
X    return (cvfixnum((FIXTYPE)oldn));
X}
X
X/* xmem - xlisp function to print memory statistics */
XLVAL xmem()
X{
X    /* allow one argument for compatiblity with common lisp */
X    if (moreargs()) xlgetarg();
X    xllastarg();
X
X    /* print the statistics */
X    stats();
X
X    /* return nil */
X    return (NIL);
X}
X
X#ifdef SAVERESTORE
X/* xsave - save the memory image */
XLVAL xsave()
X{
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgetfname());
X    xllastarg();
X
X    /* save the memory image */
X    return (xlisave(name) ? true : NIL);
X}
X
X/* xrestore - restore a saved memory image */
XLVAL xrestore()
X{
X    extern jmp_buf top_level;
X    unsigned char *name;
X
X    /* get the file name, verbose flag and print flag */
X    name = getstring(xlgetfname());
X    xllastarg();
X
X    /* restore the saved memory image */
X    if (!xlirestore(name))
X    return (NIL);
X
X    /* return directly to the top level */
X    stdputstr("[ returning to the top level ]\n");
X    longjmp(top_level,1);
X}
X#endif
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit()
X{
X    LVAL p;
X    int i;
X
X    /* initialize our internal variables */
X    segs = lastseg = NULL;
X    nnodes = nfree = total = 0L;
X    nsegs = gccalls = 0;
X    anodes = NNODES;
X    fnodes = NIL;
X
X    /* allocate the fixnum segment */
X    if ((fixseg = newsegment(SFIXSIZE)) == NULL)
X    xlfatal("insufficient memory");
X
X    /* initialize the fixnum segment */
X    p = &fixseg->sg_nodes[0];
X    for (i = SFIXMIN; i <= SFIXMAX; ++i) {
X    p->n_type = FIXNUM;
X    p->n_fixnum = i;
X    ++p;
X    }
X
X    /* allocate the character segment */
X    if ((charseg = newsegment(CHARSIZE)) == NULL)
X    xlfatal("insufficient memory");
X
X    /* initialize the character segment */
X    p = &charseg->sg_nodes[0];
X    for (i = CHARMIN; i <= CHARMAX; ++i) {
X    p->n_type = CHAR;
X    p->n_chcode = i;
X    ++p;
X    }
X
X    /* initialize structures that are marked by the collector */
X    obarray = xlenv = xlfenv = xldenv = NIL;
X    s_gcflag = s_gchook = NIL;
X
X    /* allocate the evaluation stack */
X    if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
X    xlfatal("insufficient memory");
X    xlstack = xlstktop = xlstkbase + EDEPTH;
X
X    /* allocate the argument stack */
X    if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
X    xlfatal("insufficient memory");
X    xlargstktop = xlargstkbase + ADEPTH;
X    xlfp = xlsp = xlargstkbase;
X    *xlsp++ = NIL;
X}
X
SHAR_EOF
if test 14715 -ne "`wc -c 'xldmem.c'`"
then
    echo shar: error transmitting "'xldmem.c'" '(should have been 14715 characters)'
fi
echo shar: extracting "'xldmem.h'" '(6120 characters)'
if test -f 'xldmem.h'
then
    echo shar: over-writing existing file "'xldmem.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'xldmem.h'
X/* xldmem.h - dynamic memory definitions */
X/*    Copyright (c) 1987, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X/* small fixnum range */
X#define SFIXMIN        (-128)
X#define SFIXMAX        255
X#define SFIXSIZE    384
X
X/* character range */
X#define CHARMIN        0
X#define CHARMAX        255
X#define CHARSIZE    256
X
X/* new node access macros */
X#define ntype(x)    ((x)->n_type)
X
X/* cons access macros */
X#define car(x)        ((x)->n_car)
X#define cdr(x)        ((x)->n_cdr)
X#define rplaca(x,y)    ((x)->n_car = (y))
X#define rplacd(x,y)    ((x)->n_cdr = (y))
X
X/* symbol access macros */
X#define getvalue(x)     ((x)->n_vdata[0])
X#define setvalue(x,v)     ((x)->n_vdata[0] = (v))
X#define getfunction(x)     ((x)->n_vdata[1])
X#define setfunction(x,v) ((x)->n_vdata[1] = (v))
X#define getplist(x)     ((x)->n_vdata[2])
X#define setplist(x,v)     ((x)->n_vdata[2] = (v))
X#define getpname(x)     ((x)->n_vdata[3])
X#define setpname(x,v)     ((x)->n_vdata[3] = (v))
X#define SYMSIZE        4
X
X/* closure access macros */
X#define getname(x)         ((x)->n_vdata[0])
X#define setname(x,v)       ((x)->n_vdata[0] = (v))
X#define gettype(x)        ((x)->n_vdata[1])
X#define settype(x,v)      ((x)->n_vdata[1] = (v))
X#define getargs(x)         ((x)->n_vdata[2])
X#define setargs(x,v)       ((x)->n_vdata[2] = (v))
X#define getoargs(x)        ((x)->n_vdata[3])
X#define setoargs(x,v)      ((x)->n_vdata[3] = (v))
X#define getrest(x)         ((x)->n_vdata[4])
X#define setrest(x,v)       ((x)->n_vdata[4] = (v))
X#define getkargs(x)        ((x)->n_vdata[5])
X#define setkargs(x,v)      ((x)->n_vdata[5] = (v))
X#define getaargs(x)        ((x)->n_vdata[6])
X#define setaargs(x,v)      ((x)->n_vdata[6] = (v))
X#define getbody(x)         ((x)->n_vdata[7])
X#define setbody(x,v)       ((x)->n_vdata[7] = (v))
X#define getenv(x)    ((x)->n_vdata[8])
X#define setenv(x,v)    ((x)->n_vdata[8] = (v))
X#define getfenv(x)    ((x)->n_vdata[9])
X#define setfenv(x,v)    ((x)->n_vdata[9] = (v))
X#define getlambda(x)    ((x)->n_vdata[10])
X#define setlambda(x,v)    ((x)->n_vdata[10] = (v))
X#define CLOSIZE        11
X
X/* vector access macros */
X#define getsize(x)    ((x)->n_vsize)
X#define getelement(x,i)    ((x)->n_vdata[i])
X#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
X
X/* object access macros */
X#define getclass(x)    ((x)->n_vdata[0])
X#define getivar(x,i)    ((x)->n_vdata[i+1])
X#define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
X
X/* subr/fsubr access macros */
X#define getsubr(x)    ((x)->n_subr)
X#define getoffset(x)    ((x)->n_offset)
X
X/* fixnum/flonum/char access macros */
X#define getfixnum(x)    ((x)->n_fixnum)
X#define getflonum(x)    ((x)->n_flonum)
X#define getchcode(x)    ((x)->n_chcode)
X
X/* string access macros */
X#define getstring(x)    ((x)->n_string)
X#define getslength(x)    ((x)->n_strlen)
X
X/* file stream access macros */
X#define getfile(x)    ((x)->n_fp)
X#define setfile(x,v)    ((x)->n_fp = (v))
X#define getsavech(x)    ((x)->n_savech)
X#define setsavech(x,v)    ((x)->n_savech = (v))
X
X/* unnamed stream access macros */
X#define gethead(x)    ((x)->n_car)
X#define sethead(x,v)    ((x)->n_car = (v))
X#define gettail(x)    ((x)->n_cdr)
X#define settail(x,v)    ((x)->n_cdr = (v))
X
X/* node types */
X#define FREE    0
X#define SUBR    1
X#define FSUBR    2
X#define CONS    3
X#define SYMBOL    4
X#define FIXNUM    5
X#define FLONUM    6
X#define STRING    7
X#define OBJECT    8
X#define STREAM    9
X#define VECTOR    10
X#define CLOSURE    11
X#define CHAR    12
X#define USTREAM    13
X#define STRUCT    14
X
X/* subr/fsubr node */
X#define n_subr        n_info.n_xsubr.xs_subr
X#define n_offset    n_info.n_xsubr.xs_offset
X
X/* cons node */
X#define n_car        n_info.n_xcons.xc_car
X#define n_cdr        n_info.n_xcons.xc_cdr
X
X/* fixnum node */
X#define n_fixnum    n_info.n_xfixnum.xf_fixnum
X
X/* flonum node */
X#define n_flonum    n_info.n_xflonum.xf_flonum
X/* character node */
X#define n_chcode    n_info.n_xchar.xc_chcode
X
X/* string node */
X#define n_string    n_info.n_xstring.xs_string
X#define n_strlen    n_info.n_xstring.xs_length
X
X/* stream node */
X#define n_fp        n_info.n_xstream.xs_fp
X#define n_savech    n_info.n_xstream.xs_savech
X
X/* vector/object node */
X#define n_vsize        n_info.n_xvector.xv_size
X#define n_vdata        n_info.n_xvector.xv_data
X
X/* node structure */
Xtypedef struct node {
X    char n_type;        /* type of node */
X    char n_flags;        /* flag bits */
X    union ninfo {         /* value */
X    struct xsubr {        /* subr/fsubr node */
X        struct node *(*xs_subr)();    /* function pointer */
X        int xs_offset;        /* offset into funtab */
X    } n_xsubr;
X    struct xcons {        /* cons node */
X        struct node *xc_car;    /* the car pointer */
X        struct node *xc_cdr;    /* the cdr pointer */
X    } n_xcons;
X    struct xfixnum {    /* fixnum node */
X        FIXTYPE xf_fixnum;        /* fixnum value */
X    } n_xfixnum;
X    struct xflonum {    /* flonum node */
X        FLOTYPE xf_flonum;        /* flonum value */
X    } n_xflonum;
X    struct xchar {        /* character node */
X        int xc_chcode;        /* character code */
X    } n_xchar;
X    struct xstring {    /* string node */
X        int xs_length;        /* string length */
X        unsigned char *xs_string;    /* string pointer */
X    } n_xstring;
X    struct xstream {     /* stream node */
X        FILE *xs_fp;        /* the file pointer */
X        int xs_savech;        /* lookahead character */
X    } n_xstream;
X    struct xvector {    /* vector/object/symbol/structure node */
X        int xv_size;        /* vector size */
X        struct node **xv_data;    /* vector data */
X    } n_xvector;
X    } n_info;
X} *LVAL;
X
X/* memory segment structure definition */
Xtypedef struct segment {
X    int sg_size;
X    struct segment *sg_next;
X    struct node sg_nodes[1];
X} SEGMENT;
X
X/* memory allocation functions */
Xextern LVAL cons();        /* (cons x y) */
Xextern LVAL cvsymbol();           /* convert a string to a symbol */
Xextern LVAL cvstring();           /* convert a string */
Xextern LVAL cvfile();        /* convert a FILE * to a file */
Xextern LVAL cvsubr();        /* convert a function to a subr/fsubr */
Xextern LVAL cvfixnum();           /* convert a fixnum */
Xextern LVAL cvflonum();           /* convert a flonum */
Xextern LVAL cvchar();        /* convert a character */
X
Xextern LVAL newstring();    /* create a new string */
Xextern LVAL newvector();    /* create a new vector */
Xextern LVAL newobject();    /* create a new object */
Xextern LVAL newclosure();    /* create a new closure */
Xextern LVAL newustream();    /* create a new unnamed stream */
Xextern LVAL newstruct();    /* create a new structure */
X
SHAR_EOF
if test 6120 -ne "`wc -c 'xldmem.h'`"
then
    echo shar: error transmitting "'xldmem.h'" '(should have been 6120 characters)'
fi
echo shar: extracting "'xleval.c'" '(19240 characters)'
if test -f 'xleval.c'
then
    echo shar: over-writing existing file "'xleval.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xleval.c'
X/* xleval - xlisp evaluator */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* macro to check for lambda list keywords */
X#define iskey(s) ((s) == lk_optional \
X               || (s) == lk_rest \
X               || (s) == lk_key \
X               || (s) == lk_aux \
X               || (s) == lk_allow_other_keys)
X
X/* macros to handle tracing */
X#define trenter(sym,argc,argv) {if (sym) doenter(sym,argc,argv);}
X#define trexit(sym,val) {if (sym) doexit(sym,val);}
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,xlvalue,true;
Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
Xextern LVAL s_evalhook,s_applyhook,s_tracelist;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_unbound;
Xextern int xlsample;
Xextern char buf[];
X
X/* forward declarations */
XFORWARD LVAL xlxeval();
XFORWARD LVAL evalhook();
XFORWARD LVAL evform();
XFORWARD LVAL evfun();
X
X/* xleval - evaluate an xlisp expression (checking for *evalhook*) */
XLVAL xleval(expr)
X  LVAL expr;
X{
X    /* check for control codes */
X    if (--xlsample <= 0) {
X    xlsample = SAMPLE;
X    oscheck();
X    }
X
X    /* check for *evalhook* */
X    if (getvalue(s_evalhook))
X    return (evalhook(expr));
X
X    /* check for nil */
X    if (null(expr))
X    return (NIL);
X
X    /* dispatch on the node type */
X    switch (ntype(expr)) {
X    case CONS:
X    return (evform(expr));
X    case SYMBOL:
X    return (xlgetvalue(expr));
X    default:
X    return (expr);
X    }
X}
X
X/* xlevalenv - evaluate an expression in a specified environment */
XLVAL xlevalenv(expr,env,fenv)
X  LVAL expr,env,fenv;
X{
X    LVAL oldenv,oldfenv,val;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X
X    /* establish the new environment */
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = env;
X    xlfenv = fenv;
X
X    /* evaluate the expression */
X    val = xleval(expr);
X
X    /* restore the environment */
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
XLVAL xlxeval(expr)
X  LVAL expr;
X{
X    /* check for nil */
X    if (null(expr))
X    return (NIL);
X
X    /* dispatch on node type */
X    switch (ntype(expr)) {
X    case CONS:
X    return (evform(expr));
X    case SYMBOL:
X    return (xlgetvalue(expr));
X    default:
X    return (expr);
X    }
X}
X
X/* xlapply - apply a function to arguments (already on the stack) */
XLVAL xlapply(argc)
X  int argc;
X{
X    LVAL *oldargv,fun,val;
X    int oldargc;
X
X    /* get the function */
X    fun = xlfp[1];
X
X    /* get the functional value of symbols */
X    if (symbolp(fun)) {
X    while ((val = getfunction(fun)) == s_unbound)
X        xlfunbound(fun);
X    fun = xlfp[1] = val;
X    }
X
X    /* check for nil */
X    if (null(fun))
X    xlerror("bad function",fun);
X
X    /* dispatch on node type */
X    switch (ntype(fun)) {
X    case SUBR:
X    oldargc = xlargc;
X    oldargv = xlargv;
X    xlargc = argc;
X    xlargv = xlfp + 3;
X    val = (*getsubr(fun))();
X    xlargc = oldargc;
X    xlargv = oldargv;
X    break;
X    case CONS:
X    if (!consp(cdr(fun)))
X        xlerror("bad function",fun);
X    if (car(fun) == s_lambda)
X        fun = xlclose(NIL,
X                      s_lambda,
X                      car(cdr(fun)),
X                      cdr(cdr(fun)),
X                      xlenv,xlfenv);
X    else
X        xlerror("bad function",fun);
X    /**** fall through into the next case ****/
X    case CLOSURE:
X    if (gettype(fun) != s_lambda)
X        xlerror("bad function",fun);
X    val = evfun(fun,argc,xlfp+3);
X    break;
X    default:
X    xlerror("bad function",fun);
X    }
X
X    /* remove the call frame */
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X
X    /* return the function value */
X    return (val);
X}
X
X/* evform - evaluate a form */
XLOCAL LVAL evform(form)
X  LVAL form;
X{
X    LVAL fun,args,val,type;
X    LVAL tracing=NIL;
X    LVAL *argv;
X    int argc;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fun);
X    xlsave(args);
X
X    /* get the function and the argument list */
X    fun = car(form);
X    args = cdr(form);
X
X    /* get the functional value of symbols */
X    if (symbolp(fun)) {
X    if (getvalue(s_tracelist) && member(fun,getvalue(s_tracelist)))
X        tracing = fun;
X    fun = xlgetfunction(fun);
X    }
X
X    /* check for nil */
X    if (null(fun))
X    xlerror("bad function",NIL);
X
X    /* dispatch on node type */
X    switch (ntype(fun)) {
X    case SUBR:
X    argv = xlargv;
X    argc = xlargc;
X    xlargc = evpushargs(fun,args);
X    xlargv = xlfp + 3;
X    trenter(tracing,xlargc,xlargv);
X    val = (*getsubr(fun))();
X    trexit(tracing,val);
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    xlargv = argv;
X    xlargc = argc;
X    break;
X    case FSUBR:
X    argv = xlargv;
X    argc = xlargc;
X    xlargc = pushargs(fun,args);
X    xlargv = xlfp + 3;
X    val = (*getsubr(fun))();
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    xlargv = argv;
X    xlargc = argc;
X    break;
X    case CONS:
X    if (!consp(cdr(fun)))
X        xlerror("bad function",fun);
X    if ((type = car(fun)) == s_lambda)
X         fun = xlclose(NIL,
X                       s_lambda,
X                       car(cdr(fun)),
X                       cdr(cdr(fun)),
X                       xlenv,xlfenv);
X    else
X        xlerror("bad function",fun);
X    /**** fall through into the next case ****/
X    case CLOSURE:
X    if (gettype(fun) == s_lambda) {
X        argc = evpushargs(fun,args);
X        argv = xlfp + 3;
X        trenter(tracing,argc,argv);
X        val = evfun(fun,argc,argv);
X        trexit(tracing,val);
X        xlsp = xlfp;
X        xlfp = xlfp - (int)getfixnum(*xlfp);
X    }
X    else {
X        macroexpand(fun,args,&fun);
X        val = xleval(fun);
X    }
X    break;
X    default:
X    xlerror("bad function",fun);
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlexpandmacros - expand macros in a form */
XLVAL xlexpandmacros(form)
X  LVAL form;
X{
X    LVAL fun,args;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlprotect(form);
X    xlsave(fun);
X    xlsave(args);
X
X    /* expand until the form isn't a macro call */
X    while (consp(form)) {
X    fun = car(form);        /* get the macro name */
X    args = cdr(form);        /* get the arguments */
X    if (!symbolp(fun) || !fboundp(fun))
X        break;
X    fun = xlgetfunction(fun);    /* get the expansion function */
X    if (!macroexpand(fun,args,&form))
X        break;
X    }
X
X    /* restore the stack and return the expansion */
X    xlpopn(3);
X    return (form);
X}
X
X/* macroexpand - expand a macro call */
Xint macroexpand(fun,args,pval)
X  LVAL fun,args,*pval;
X{
X    LVAL *argv;
X    int argc;
X
X    /* make sure it's really a macro call */
X    if (!closurep(fun) || gettype(fun) != s_macro)
X    return (FALSE);
X
X    /* call the expansion function */
X    argc = pushargs(fun,args);
X    argv = xlfp + 3;
X    *pval = evfun(fun,argc,argv);
X    xlsp = xlfp;
X    xlfp = xlfp - (int)getfixnum(*xlfp);
X    return (TRUE);
X}
X
X/* evalhook - call the evalhook function */
XLOCAL LVAL evalhook(expr)
X  LVAL expr;
X{
X    LVAL *newfp,olddenv,val;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(getvalue(s_evalhook));
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(expr);
X    pusharg(cons(xlenv,xlfenv));
X    xlfp = newfp;
X
X    /* rebind the hook functions to nil */
X    olddenv = xldenv;
X    xldbind(s_evalhook,NIL);
X    xldbind(s_applyhook,NIL);
X
X    /* call the hook function */
X    val = xlapply(2);
X
X    /* unbind the symbols */
X    xlunbind(olddenv);
X
X    /* return the value */
X    return (val);
X}
X
X/* evpushargs - evaluate and push a list of arguments */
XLOCAL int evpushargs(fun,args)
X  LVAL fun,args;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* protect the argument list */
X    xlprot1(args);
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL); /* will be argc */
X
X    /* evaluate and push each argument */
X    for (argc = 0; consp(args); args = cdr(args), ++argc)
X    pusharg(xleval(car(args)));
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the number of arguments */
X    return (argc);
X}
X
X/* pushargs - push a list of arguments */
Xint pushargs(fun,args)
X  LVAL fun,args;
X{
X    LVAL *newfp;
X    int argc;
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL); /* will be argc */
X
X    /* push each argument */
X    for (argc = 0; consp(args); args = cdr(args), ++argc)
X    pusharg(car(args));
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* return the number of arguments */
X    return (argc);
X}
X
X/* makearglist - make a list of the remaining arguments */
XLVAL makearglist(argc,argv)
X  int argc; LVAL *argv;
X{
X    LVAL list,this,last;
X    xlsave1(list);
X    for (last = NIL; --argc >= 0; last = this) {
X    this = cons(*argv++,NIL);
X    if (last) rplacd(last,this);
X    else list = this;
X    last = this;
X    }
X    xlpop();
X    return (list);
X}
X
X/* evfun - evaluate a function */
XLOCAL LVAL evfun(fun,argc,argv)
X  LVAL fun; int argc; LVAL *argv;
X{
X    LVAL oldenv,oldfenv,cptr,name,val;
X    CONTEXT cntxt;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X    xlsave(cptr);
X
X    /* create a new environment frame */
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = xlframe(getenv(fun));
X    xlfenv = getfenv(fun);
X
X    /* bind the formal parameters */
X    xlabind(fun,argc,argv);
X
X    /* setup the implicit block */
X    if (name = getname(fun))
X    xlbegin(&cntxt,CF_RETURN,name);
X
X    /* execute the block */
X    if (name && setjmp(cntxt.c_jmpbuf))
X    val = xlvalue;
X    else
X    for (val = NIL, cptr = getbody(fun); consp(cptr); cptr = cdr(cptr))
X        val = xleval(car(cptr));
X
X    /* finish the block context */
X    if (name)
X    xlend(&cntxt);
X
X    /* restore the environment */
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xlclose - create a function closure */
XLVAL xlclose(name,type,fargs,body,env,fenv)
X  LVAL name,type,fargs,body,env,fenv;
X{
X    LVAL closure,key,arg,def,svar,new,last;
X    char keyname[STRMAX+2];
X
X    /* protect some pointers */
X    xlsave1(closure);
X
X    /* create the closure object */
X    closure = newclosure(name,type,env,fenv);
X    setlambda(closure,fargs);
X    setbody(closure,body);
X
X    /* handle each required argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X    /* make sure the argument is a symbol */
X    if (!symbolp(arg))
X        badarglist();
X
X    /* create a new argument list entry */
X    new = cons(arg,NIL);
X
X    /* link it into the required argument list */
X    if (last)
X        rplacd(last,new);
X    else
X        setargs(closure,new);
X    last = new;
X
X    /* move the formal argument list pointer ahead */
X    fargs = cdr(fargs);
X    }
X
X    /* check for the '&optional' keyword */
X    if (consp(fargs) && car(fargs) == lk_optional) {
X    fargs = cdr(fargs);
X
X    /* handle each optional argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the default expression and specified-p variable */
X        def = svar = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def)) {
X            if (svar = cdr(def))
X                if (consp(svar)) {
X                svar = car(svar);
X                if (!symbolp(svar))
X                    badarglist();
X                }
X                else
X                badarglist();
X            def = car(def);
X            }
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded optional expression */
X        new = cons(cons(arg,cons(def,cons(svar,NIL))),NIL);
X
X        /* link it into the optional argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setoargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* check for the '&rest' keyword */
X    if (consp(fargs) && car(fargs) == lk_rest) {
X    fargs = cdr(fargs);
X
X    /* get the &rest argument */
X    if (consp(fargs) && (arg = car(fargs)) && !iskey(arg) && symbolp(arg))
X        setrest(closure,arg);
X    else
X        badarglist();
X
X    /* move the formal argument list pointer ahead */
X    fargs = cdr(fargs);
X    }
X
X    /* check for the '&key' keyword */
X    if (consp(fargs) && car(fargs) == lk_key) {
X    fargs = cdr(fargs);
X
X     /* handle each key argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the default expression and specified-p variable */
X        def = svar = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def)) {
X            if (svar = cdr(def))
X                if (consp(svar)) {
X                svar = car(svar);
X                if (!symbolp(svar))
X                    badarglist();
X                }
X                else
X                badarglist();
X            def = car(def);
X            }
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* get the keyword and the variable */
X        if (consp(arg)) {
X        key = car(arg);
X        if (!symbolp(key))
X            badarglist();
X        if (arg = cdr(arg))
X            if (consp(arg))
X            arg = car(arg);
X            else
X            badarglist();
X        }
X        else if (symbolp(arg)) {
X        strcpy(keyname,":");
X        strcat(keyname,getstring(getpname(arg)));
X        key = xlenter(keyname);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded key expression */
X        new = cons(cons(key,cons(arg,cons(def,cons(svar,NIL)))),NIL);
X
X        /* link it into the optional argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setkargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* check for the '&allow-other-keys' keyword */
X    if (consp(fargs) && car(fargs) == lk_allow_other_keys)
X    fargs = cdr(fargs);    /* this is the default anyway */
X
X    /* check for the '&aux' keyword */
X    if (consp(fargs) && car(fargs) == lk_aux) {
X    fargs = cdr(fargs);
X
X    /* handle each aux argument */
X    last = NIL;
X    while (consp(fargs) && (arg = car(fargs)) && !iskey(arg)) {
X
X        /* get the initial value */
X        def = NIL;
X        if (consp(arg)) {
X        if (def = cdr(arg))
X            if (consp(def))
X            def = car(def);
X            else
X            badarglist();
X        arg = car(arg);
X        }
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        badarglist();
X
X        /* create a fully expanded aux expression */
X        new = cons(cons(arg,cons(def,NIL)),NIL);
X
X        /* link it into the aux argument list */
X        if (last)
X        rplacd(last,new);
X        else
X        setaargs(closure,new);
X        last = new;
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* make sure this is the end of the formal argument list */
X    if (fargs)
X    badarglist();
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new closure */
X    return (closure);
X}
X
X/* xlabind - bind the arguments for a function */
Xxlabind(fun,argc,argv)
X  LVAL fun; int argc; LVAL *argv;
X{
X    LVAL *kargv,fargs,key,arg,def,svar,p;
X    int rargc,kargc;
X
X    /* protect some pointers */
X    xlsave1(def);
X
X    /* bind each required argument */
X    for (fargs = getargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* make sure there is an actual argument */
X    if (--argc < 0)
X        xlfail("too few arguments");
X
X    /* bind the formal variable to the argument value */
X    xlbind(car(fargs),*argv++);
X    }
X
X    /* bind each optional argument */
X    for (fargs = getoargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* get argument, default and specified-p variable */
X    p = car(fargs);
X    arg = car(p); p = cdr(p);
X    def = car(p); p = cdr(p);
X    svar = car(p);
X
X    /* bind the formal variable to the argument value */
X    if (--argc >= 0) {
X        xlbind(arg,*argv++);
X        if (svar) xlbind(svar,true);
X    }
X
X    /* bind the formal variable to the default value */
X    else {
X        if (def) def = xleval(def);
X        xlbind(arg,def);
X        if (svar) xlbind(svar,NIL);
X    }
X    }
X
X    /* save the count of the &rest of the argument list */
X    rargc = argc;
X
X    /* handle '&rest' argument */
X    if (arg = getrest(fun)) {
X    def = makearglist(argc,argv);
X    xlbind(arg,def);
X    argc = 0;
X    }
X
X    /* handle '&key' arguments */
X    if (fargs = getkargs(fun)) {
X    for (; fargs; fargs = cdr(fargs)) {
X
X        /* get keyword, argument, default and specified-p variable */
X        p = car(fargs);
X        key = car(p); p = cdr(p);
X        arg = car(p); p = cdr(p);
X        def = car(p); p = cdr(p);
X        svar = car(p);
X
X        /* look for the keyword in the actual argument list */
X        for (kargv = argv, kargc = rargc; (kargc -= 2) >= 0; kargv += 2)
X        if (*kargv == key)
X            break;
X
X        /* bind the formal variable to the argument value */
X        if (kargc >= 0) {
X        xlbind(arg,*++kargv);
X        if (svar) xlbind(svar,true);
X        }
X
X        /* bind the formal variable to the default value */
X        else {
X        if (def) def = xleval(def);
X        xlbind(arg,def);
X        if (svar) xlbind(svar,NIL);
X        }
X    }
X    argc = 0;
X    }
X
X    /* check for the '&aux' keyword */
X    for (fargs = getaargs(fun); fargs; fargs = cdr(fargs)) {
X
X    /* get argument and default */
X    p = car(fargs);
X    arg = car(p); p = cdr(p);
X    def = car(p);
X
X    /* bind the auxiliary variable to the initial value */
X    if (def) def = xleval(def);
X    xlbind(arg,def);
X    }
X
X    /* make sure there aren't too many arguments */
X    if (argc > 0)
X    xlfail("too many arguments");
X
X    /* restore the stack */
X    xlpop();
X}
X
X/* doenter - print trace information on function entry */
XLOCAL doenter(sym,argc,argv)
X  LVAL sym; int argc; LVAL *argv;
X{
X    extern int xltrcindent;
X    int i;
X
X    /* indent to the current trace level */
X    for (i = 0; i < xltrcindent; ++i)
X    trcputstr(" ");
X    ++xltrcindent;
X
X    /* display the function call */
X    sprintf(buf,"Entering: %s, Argument list: (",getstring(getpname(sym)));
X    trcputstr(buf);
X    while (--argc >= 0) {
X    trcprin1(*argv++);
X    if (argc) trcputstr(" ");
X    }
X    trcputstr(")\n");
X}
X
X/* doexit - print trace information for function/macro exit */
XLOCAL doexit(sym,val)
X  LVAL sym,val;
X{
X    extern int xltrcindent;
X    int i;
X
X    /* indent to the current trace level */
X    --xltrcindent;
X    for (i = 0; i < xltrcindent; ++i)
X    trcputstr(" ");
X
X    /* display the function value */
X    sprintf(buf,"Exiting: %s, Value: ",getstring(getpname(sym)));
X    trcputstr(buf);
X    trcprin1(val);
X    trcputstr("\n");
X}
X
X/* member - is 'x' a member of 'list'? */
XLOCAL int member(x,list)
X  LVAL x,list;
X{
X    for (; consp(list); list = cdr(list))
X    if (x == car(list))
X        return (TRUE);
X    return (FALSE);
X}
X
X/* xlunbound - signal an unbound variable error */
Xxlunbound(sym)
X  LVAL sym;
X{
X    xlcerror("try evaluating symbol again","unbound variable",sym);
X}
X
X/* xlfunbound - signal an unbound function error */
Xxlfunbound(sym)
X  LVAL sym;
X{
X    xlcerror("try evaluating symbol again","unbound function",sym);
X}
X
X/* xlstkoverflow - signal a stack overflow error */
Xxlstkoverflow()
X{
X    xlabort("evaluation stack overflow");
X}
X
X/* xlargstkoverflow - signal an argument stack overflow error */
Xxlargstkoverflow()
X{
X    xlabort("argument stack overflow");
X}
X
X/* badarglist - report a bad argument list error */
XLOCAL badarglist()
X{
X    xlfail("bad formal argument list");
X}
SHAR_EOF
if test 19240 -ne "`wc -c 'xleval.c'`"
then
    echo shar: error transmitting "'xleval.c'" '(should have been 19240 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc